home *** CD-ROM | disk | FTP | other *** search
/ ShareWare OnLine 2 / ShareWare OnLine Volume 2 (CMS Software)(1993).iso / cad / acadfont.zip / BIGLET.LSP < prev    next >
Text File  |  1993-02-19  |  5KB  |  166 lines
  1. ;COPYRIGHT 1992 OMEGA ENGINEERING SOFTWARE
  2. (DEFUN ZOOMW ()
  3.   (COMMAND "ZOOM" "W" (LIST (- (CAR PT1) 20) (- (CADR PT1) 20) 0) (LIST (+ (+ (CAR PT1) 20) (* SC 14 4)) (CADR PT1) 0))
  4. )
  5.  
  6. (DEFUN PLOTLET ()
  7.  
  8.    (SETQ TEMPPT (LIST (CADR (CAR LTEMP)) (CADDR (CAR LTEMP)) 0))
  9.    (SETQ TEMPPT1 (LIST (CADR (CAR LTEMP)) (CADDR (CAR LTEMP)) 0))
  10.    (SETQ I 1)
  11.    (REPEAT (- (CAR POS) 1)
  12.        (IF (= (CAR (NTH I LTEMP)) 1)
  13.            (COMMAND "PLINE" TEMPPT "W" WI WI (LIST (CADR (NTH I LTEMP)) (CADDR (NTH I LTEMP)) 0) "")
  14.            (COMMAND "PLINE" TEMPPT "W" WI WI "ARC" (LIST (CADR (NTH I LTEMP)) (CADDR (NTH I LTEMP)) 0) "")
  15.        )
  16.        (SETQ EN1 (ENTLAST))
  17.        (SETQ PT (CDR (ASSOC 10 (ENTGET (ENTNEXT EN1)))))
  18.        (IF (> I 1)
  19.          (COMMAND "PEDIT" TEMPPT1 "JOIN" PT "" ^C)
  20.        )
  21.        (SETQ TEMPPT (LIST (CADR (NTH I LTEMP)) (CADDR (NTH I LTEMP)) 0))
  22.        (SETQ I (+ I 1))
  23.    )
  24.    (SETQ TEMPPT (LIST (CADR (NTH I LTEMP)) (CADDR (NTH I LTEMP)) 0))
  25.    (SETQ TEMPPT1 (LIST (CADR (NTH I LTEMP)) (CADDR (NTH I LTEMP)) 0))
  26.    (REPEAT (- (CADR POS) 1)
  27.        (IF (= (CAR (NTH (+ I 1) LTEMP)) 1)
  28.            (COMMAND "PLINE" TEMPPT "W" WI WI (LIST (CADR (NTH (+ I 1) LTEMP)) (CADDR (NTH (+ I 1) LTEMP)) 0) "")
  29.            (COMMAND "PLINE" TEMPPT "W" WI WI "ARC" (LIST (CADR (NTH (+ I 1) LTEMP)) (CADDR (NTH (+ I 1) LTEMP)) 0) "")
  30.        )
  31.        (SETQ EN1 (ENTLAST))
  32.        (SETQ PT (CDR (ASSOC 10 (ENTGET (ENTNEXT EN1)))))
  33.        (IF (> I (CAR POS))
  34.          (COMMAND "PEDIT" TEMPPT1 "JOIN" PT "" ^C)
  35.        )
  36.        (SETQ I (+ I 1))
  37.        (SETQ TEMPPT (LIST (CADR (NTH I LTEMP)) (CADDR (NTH I LTEMP)) 0))
  38.    )
  39. )
  40.  
  41. (DEFUN PARSL ()
  42.    (SETQ L (READ L))
  43.    (SETQ BOXX (* SC (NTH 3 L)))
  44.    (SETQ BOXY (* SC 16))
  45.  
  46.    (SETQ PYB (/ WI 2.0))
  47.    (SETQ PYT (- BOXY (/ WI 2.0)))
  48.    (SETQ PXL (/ WI 2.0))
  49.    (SETQ PXR (- BOXX (/ WI 2.0)))
  50.    (SETQ PB (- (/ BOXY 2) (* WI 0.25)))
  51.    (SETQ PX1 (+ (* SC 2.0) (/ WI 2)))
  52.    (SETQ PX2 (- BOXX (+ (* SC 2.0) (/ WI 2.0))))
  53.    (SETQ PY1 (+ (* SC 2.0) (/ WI 2.0)))
  54.    (SETQ PY2 (- (- BOXY  (* SC 2)) (/ WI 2.0)))
  55.    (SETQ PY3 (+ (/ BOXY 2) (* SC 2)))
  56.    (SETQ PY4 (- (/ BOXY 2) (* SC 2)))
  57.  
  58.    (SETQ POS (LIST (CADR L) (CADDR L) (NTH 3 L)))
  59.    (SETQ LEN (LENGTH L))
  60.    (SETQ I 4)
  61.    (SETQ K 1)
  62.    (SETQ LT (LIST (CAR L) (CADR L) (CADDR L) (NTH 3 L) (NTH 4 L)))
  63.    (REPEAT (- LEN 5)
  64.      (SETQ I (+ I 1))
  65.      (SETQ K (+ K 1))
  66.      (IF (< K 4)
  67.        (PROGN
  68.           (IF (NUMBERP (NTH I L))
  69.              (SETQ LT1 (* SC (NTH I L)))
  70.              (SETQ LT1 (NTH I L))
  71.           )
  72.         )
  73.         (PROGN
  74.            (SETQ K 1)
  75.            (SETQ LT1 (NTH I L))
  76.         )
  77.       )
  78.       (SETQ LT (APPEND LT (LIST LT1)))
  79.     )
  80.    (SETQ L LT)
  81.  
  82.    (SETQ L (SUBST PXL 'PXL L))
  83.    (SETQ L (SUBST PXR 'PXR L))
  84.    (SETQ L (SUBST PYT 'PYT L))
  85.    (SETQ L (SUBST PYB 'PYB L))
  86.    (SETQ L (SUBST PB 'PB L))
  87.    (SETQ L (SUBST PX1 'PX1 L))
  88.    (SETQ L (SUBST PX2 'PX2 L))
  89.    (SETQ L (SUBST PY1 'PY1 L))
  90.    (SETQ L (SUBST PY2 'PY2 L))
  91.    (SETQ L (SUBST PY3 'PY3 L))
  92.    (SETQ L (SUBST PY4 'PY4 L))
  93.  
  94.    (SETQ LTEMP NIL)
  95.    (SETQ I 0)
  96.    (REPEAT (/ (- LEN 4) 3)
  97.        (SETQ LTEMP (APPEND LTEMP (LIST (LIST  (NTH (+ I 4) L)
  98.                                               (+ (CAR PT1) (NTH (+ I 5) L))
  99.                                               (+ (CADR PT1) (NTH (+ I 6) L))))))
  100.        (SETQ I (+ I 3))
  101.    )
  102.    (PLOTLET)
  103.  
  104. )
  105.  
  106.  
  107. (DEFUN FINDLET ()
  108.    (SETQ L (READ-LINE FP))
  109.    (WHILE (AND (/= L NIL) (/= LET (SUBSTR L 3 1)))
  110.      (SETQ L (READ-LINE FP))
  111.    )
  112.    (IF (/= L NIL)
  113.       (PARSL)
  114.    )
  115.  
  116. )
  117.  
  118. (DEFUN PARSSTR ()
  119.   (SETQ LETNUM (+ LETNUM 1))
  120.   (SETQ LET (SUBSTR STR LETNUM 1))
  121.   (FINDLET)
  122.   (IF (/= L NIL)
  123.     (SETQ PT1 (LIST (+ (CAR PT1) (* SC (+ (CADDR POS) 2))) (CADR PT1) (CADDR PT1)))
  124.     (SETQ PT1 (LIST (+ (CAR PT1) (* SC 14)) (CADR PT1) (CADDR PT1)))
  125.   )
  126. )
  127.  
  128.  
  129. (DEFUN C:BIGLET (/ PT1 HE WI STR LETNUM SC PB FP LET L BOXX BOXY PYT PYB
  130.                    PXL PXR PY1 PY2 PY3 PY4 PB I LTEMP K PT TEMPT TEMPT1
  131.                    EN1 POS LEN PX1 PX2 LT LT1)
  132.  
  133.    (SETQ PT1 (GETPOINT "\nSTART POINT :"))
  134.    (SETQ HE (GETREAL "\nHEIGHT :"))
  135.    (SETQ WI (GETREAL "\nWIDTH :"))
  136.    (SETQ STR (GETSTRING 2 "\nTEXT :"))
  137.    (IF (< 0.18 (/ WI HE ))
  138.      (SETQ WI (* 0.18 HE))
  139.    )
  140.  
  141.    (SETQ LETNUM 0)
  142.    (SETQ SC (/ HE 16))
  143.    (SETQ PB (GETVAR "PICKBOX"))
  144.    (SETVAR "PICKBOX" 1)
  145.  
  146.    (SETQ FP (OPEN "BIGLET.DAT" "r"))
  147.       (IF (/= FP NIL)
  148.         (PROGN
  149.           (REPEAT (STRLEN STR)
  150.             (IF (= (REM LETNUM 4) 0)
  151.               (ZOOMW)
  152.             )
  153.             (PARSSTR)
  154.             (CLOSE FP)
  155.             (SETQ FP (OPEN "BIGLET.DAT" "r"))
  156.           )
  157.           (CLOSE FP)
  158.         )
  159.         (PROMPT "\nFILE BIGLET.DAT FILE NOT FOUND :")
  160.       )
  161.    (SETVAR "PICKBOX" PB)
  162. )
  163.  
  164.  
  165.  
  166.